home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / sys / ae_vmport.t next >
Encoding:
Text File  |  1988-02-05  |  14.1 KB  |  437 lines
  1. (herald aegis_vmport
  2.   (env tsys
  3.        (osys aegis_fault)
  4.        (osys buffer)))
  5.  
  6. ;;; The Aegis interface to I/O routines.
  7.  
  8. ;;; This file contains the virtual machine I/O interface to the
  9. ;;; aegis operating system.  Where possible we use IOS calls rather
  10. ;;; than say NAME calls, so that T takes advantage of Extensible
  11. ;;; ports.
  12.  
  13. ;;; Used on startup.
  14.  
  15. (define (%VM-BOOT-WRITE-TTY sym)
  16.   (vfmt "%A%." sym (symbol-length sym)))
  17.  
  18. (define-foreign vfmt ("VFMT_$WRITE2" (in rep/string)
  19.                                    (in rep/extend)
  20.                                    (in rep/integer))
  21.         ignore)
  22.  
  23. ;;; Z system i/o
  24.  
  25. (define-set-of ios_$put_get_opts_t
  26.                ios_$cond_opt
  27.                ios_$preview_opt
  28.                ios_$partial_record_opt
  29.                ios_$no_rec_bndry_opt)
  30.  
  31. (define-constant %%standard-input  0)
  32. (define-constant %%standard-output 1)
  33. (define-constant %%error-input     2)
  34. (define-constant %%error-output    3)
  35.  
  36. ;;; Input
  37.  
  38. (define-constant aegis-eof     #x01270009)   ; ios_$end_of_file
  39. (define-constant aegis-no-data #x0127003E)   ; ios_$get_conditional_failed
  40.  
  41. (define (%VM-READ-BUFFER IOB BLOCK?)
  42.   (let ((get_opts (fx-ior (if block? ios_$cond_opt 0)
  43.                           (if (iob-interactive? iob)
  44.                               0
  45.                               ios_$no_rec_bndry_opt))))
  46.     (receive (length status) (ios_$get (iob-channel iob)
  47.                                        get_opts
  48.                                        (iob-buffer iob)
  49.                                        (max-buffer-length iob)
  50.                                        nil)
  51. ;++    (format t "~&sts= ~x len= ~d~%" status length)
  52.       (cond ((fx= 0 status)
  53.              (set (iob-offset iob) 0)
  54.              (set (iob-limit iob) length)
  55.              (set (iob-eof-flag? iob) nil)
  56.              length)
  57.             ((fx= aegis-no-data status)
  58.              nil)
  59.             ((fx=  aegis-eof status)
  60.              (set (iob-eof-flag? iob) t)
  61.              eof)
  62.             (else
  63.              (local-os-error status))))))
  64.  
  65. (define-foreign ios_$get
  66.   ("IOS_$GET" (in     rep/integer-16-u  port-id)
  67.             (in     rep/integer-16-u  put-get-options)
  68.             (ignore rep/extend        buffer)
  69.             (in     rep/integer       bufmax)
  70.             (out    rep/integer       status))
  71.     rep/integer)
  72.  
  73. ;;; Block input
  74.  
  75. (DEFINE (%VM-READ-PARTIAL-BLOCK IOB LOC)
  76.   (receive (length status)
  77.            (ios_$get-partial (iob-channel iob)
  78.                              (if (iob-interactive? iob)
  79.                                  0
  80.                                  ios_$no_rec_bndry_opt)
  81.                              loc
  82.                              (string-length loc)
  83.                              nil)
  84. ;    (format t "~&partial: sts= ~x len= ~d~%" status length)
  85.     (cond ((fx= 0 status)
  86.            (set (iob-eof-flag? iob) nil)
  87.            length)
  88.           ((fx=  aegis-eof status)
  89.            (set (iob-eof-flag? iob) t)
  90.            eof)
  91.           (else
  92.            (local-os-error status)))))
  93.  
  94. (define-foreign ios_$get-partial
  95.   ("IOS_$GET" (in     rep/integer-16-u  port-id)
  96.             (in     rep/integer-16-u  put-get-options)
  97.             (ignore rep/string        buffer)
  98.             (in     rep/integer       bufmax)
  99.             (out    rep/integer       status))
  100.     rep/integer)
  101.  
  102.  
  103. ;;; Output
  104.  
  105. (define (%VM-WRITE-BUFFER iob)
  106.   (cond ((fx> (iob-offset iob) 0)
  107.          (let ((status (ios_$put (iob-channel iob)
  108.                                  0
  109.                                  (iob-buffer iob)
  110.                                  (iob-offset iob)
  111.                                  nil)))
  112.            (cond ((fx= 0 status)
  113.                   (set (iob-offset iob) 0))
  114.                  (else
  115.                   (local-os-error status))))))
  116.   (no-value))
  117.  
  118. (define-foreign ios_$put
  119.   ("IOS_$PUT" (in     rep/integer-16-u  port-id)
  120.             (in     rep/integer-16-u  put-get-options)
  121.             (ignore rep/extend        buffer)
  122.             (in     rep/integer       buffer-size)
  123.             (out    rep/integer       status))
  124.     ignore)
  125.  
  126. ;;; Newline is system dependent because of OS's like VMS.
  127.  
  128. (define-integrable (%vm-newline iob)
  129.   (vm-write-char iob #\newline))
  130.  
  131. ;;; Block output
  132.  
  133. (define (%VM-WRITE-BLOCK IOB LOC)
  134.   (check-status (ios_$put-string (iob-channel iob)
  135.                                  0
  136.                                  loc
  137.                                  (string-length loc)
  138.                                  '#f))
  139.   (no-value))
  140.  
  141. (define-foreign ios_$put-string
  142.   ("IOS_$PUT" (in     rep/integer-16-u  port-id)
  143.             (in     rep/integer-16-u  put-get-options)
  144.             (ignore rep/string        buffer)
  145.             (in     rep/integer       buffer-size)
  146.             (out    rep/integer       status))
  147.     ignore)
  148.  
  149. (define ios_$illegal_operation #x01270002)
  150.  
  151. (define (%VM-FORCE-OUTPUT IOB)
  152.   (let ((status (ios_$force_write_file (iob-channel iob) nil)))
  153.     (cond ((or (fx= status 0) (fx= status ios_$illegal_operation))
  154.            (no-value))
  155.           (else
  156.            (local-os-error status)))))
  157.  
  158. (define-foreign ios_$force_write_file
  159.   ("IOS_$FORCE_WRITE_FILE" (in  rep/integer-16-u port-id)
  160.                          (out rep/integer      status))
  161.                 ignore)
  162.  
  163. ;;; The rest of this file doesn't have to be implemented to get
  164. ;;; the Z System booted.
  165.  
  166. ;;; Pathnames
  167.  
  168. ;;; Pathnames are system dependent objects used for naming files
  169. ;;; internally.  They should not be accessible outside of this file.
  170.  
  171. ;;; FILESPEC    -   Something that ->FILENAME can handle
  172. ;;; FILENAME    -   The result of  ->FILENAME
  173. ;;; PATHNAME    -   A string in the LOCAL-OS format
  174. ;;; (->PATHNAME filespec) => pathname
  175.  
  176. (define-constant name_$pnamelen_max 256)
  177.  
  178. (define-constant pathname? string?)
  179.  
  180. (define-constant pathname-length string-length)
  181.  
  182. ;;; ->PATHNAME provides the VM with a portable interface to the
  183. ;;; various file systems.
  184.  
  185. (define (->pathname filespec)
  186.   (cond ((pathname? filespec) filespec)
  187.         ((not (file-system-present?))
  188.          (vm-error "Filespecs must be strings in VM."))
  189.         ((filename? filespec) (filename->string filespec))
  190.         (else
  191.          (filename->string (->filename filespec)))))
  192.  
  193. ;;; Random Aegis definitions
  194.  
  195. (define-set-of ios_$open_options_t
  196.                ios_$no_open_delay_opt
  197.                ios_$write_opt
  198.                ios_$unregulated_opt
  199.                ios_$position_to_eof_opt
  200.                ios_$inquire_only_opt
  201.                )
  202.  
  203. (define-enumerated ios_$create_mode_t
  204.                    ios_$no_pre_exist_mode
  205.                    ios_$preserve_mode
  206.                    ios_$recreate_mode
  207.                    ios_$truncate_mode
  208.                    ios_$make_backup_mode
  209.                    ios_$loc_name_only_mode
  210.                    )
  211.  
  212. ;;; Aegis UID's
  213.  
  214. (define-constant (MAKE-UID_$T)
  215.   (make-bytev 8))
  216.  
  217. (define-constant UID_$NIL (make-uid_$t))
  218.  
  219. ;;; File opening and closing.
  220. ;++ What about pads, sockets, etc.
  221. ;++ There should be a population of all open IOB's.
  222.  
  223. ;++ What should the buffer size be?
  224.  
  225. (define default-buffer-size 1024)
  226.  
  227. (define (%vm-open-file caller fd modespec size)
  228.   (let* ((path (->pathname (if (iob? fd) (iob-id fd) fd)))
  229.          (len  (pathname-length path))
  230.          (mode (mode->iob-mode caller fd modespec))
  231.          (size (if (iob-mode? mode iob/inquire) 0 size)))
  232.     (receive (port-id status)
  233.              (cond ((iob-mode? mode iob/read)
  234.                     (ios_$open path len 0 nil))
  235.                    ((iob-mode? mode iob/write)
  236.                     (ios_$create path
  237.                                  len
  238.                                  uid_$nil
  239.                                  ios_$truncate_mode
  240.                                  ios_$write_opt
  241.                                  nil
  242.                                  nil))
  243.                    ((iob-mode? mode iob/inquire)
  244.                     (ios_$open path len ios_$inquire_only_opt nil))
  245.                    ((iob-mode? mode iob/append)
  246.                     (ios_$create path
  247.                                  len
  248.                                  uid_$nil
  249.                                  ios_$preserve_mode
  250.                                  (fx-xor ios_$write_opt
  251.                                          ios_$position_to_eof_opt)
  252.                                  nil
  253.                                  nil))
  254.                    (else
  255.                     (unsupported-mode-error caller fd modespec)))
  256.       (cond ((fxN= 0 status) nil)
  257.             (else
  258.              (let ((iob (get-i/o-buffer %buffer-pool fd port-id mode size)))
  259.           ;++     (set (table-entry open-port-table iob) (object-hash iob))
  260.                iob))))))
  261.  
  262. (define-foreign ios_$create
  263.   ("IOS_$CREATE" (in  rep/string       name)
  264.                (in  rep/integer-16-u namelength)
  265.                (in  rep/extend       type-uid)
  266.                (in  rep/integer-16-u create-mode)
  267.                (in  rep/integer-16-u open-options)
  268.                (out rep/integer-16-u port-id)
  269.                (out rep/integer      status))
  270.     ignore)
  271.  
  272. (define-foreign ios_$open
  273.   ("IOS_$OPEN" (in  rep/string       name)
  274.              (in  rep/integer-16-u namelength)
  275.              (in  rep/integer-16-u open-options)
  276.              (out rep/integer      status))
  277.     rep/integer)
  278.  
  279. (define (%vm-close-file iob)
  280.   (check-status (ios_$close (iob-channel iob) nil)))
  281.  
  282. (define-foreign ios_$close
  283.   ("IOS_$CLOSE" (in  rep/integer-16-u port-id)
  284.               (out rep/integer      status))
  285.     ignore)
  286.  
  287. ;;; File mapping
  288.  
  289. (define-enumerated ms_$conc_mode_t
  290.                    ms_$nr_xor_1w
  291.                    ms_$cowriters)
  292.  
  293. (define-enumerated ms_$acc_mode_t
  294.                    ms_$r
  295.                    ms_$rx
  296.                    ms_$wr
  297.                    ms_$wrx
  298.                    ms_$riw)
  299.  
  300. ; do area's need UID's
  301.  
  302. (define (%VM-MAP-AREA FILESPEC SIZE)
  303.   (let* ((path (->pathname filespec))
  304.          (len  (pathname-length path))
  305.          (size (fx* size 4)))
  306.     (if (not (file-exists? path))
  307.         (close-port (open-port path 'out)))
  308.     (receive (begin length status)
  309.              (ms_$mapl path len 0 size ms_$nr_xor_1w ms_$wr -1 nil nil)
  310.       (ignore length)
  311.       (check-status status)
  312.       (create-area filespec begin size nil))))
  313.  
  314. (define-foreign ms_$mapl
  315.   ("MS_$MAPL" (in  rep/string       name)
  316.             (in  rep/integer-16-u namelength)
  317.             (in  rep/integer      start)
  318.             (in  rep/integer      desired-length)
  319.             (in  rep/integer-16-u concurency)
  320.             (in  rep/integer-16-u access)
  321.             (in  rep/integer-8-s  extend)
  322.             (out rep/integer      length)
  323.             (out rep/integer      status))
  324.   rep/address)
  325.  
  326. (define (%VM-MAKE-AREA FILESPEC SIZE)
  327.   (let* ((path (->pathname filespec))
  328.          (len  (pathname-length path))
  329.          (size (fx* size 4)))
  330.     (receive (begin status)
  331.              (ms_$crmapl path len 0 size ms_$nr_xor_1w nil)
  332.       (check-status status)
  333.       (create-area filespec begin size nil))))
  334.  
  335. (define-foreign ms_$crmapl
  336.   ("MS_$CRMAPL" (in  rep/string       name)
  337.               (in  rep/integer-16-u namelength)
  338.               (in  rep/integer      start)
  339.               (in  rep/integer      desired-length)
  340.               (in  rep/integer-16-u concurency)
  341.               (out rep/integer      status))
  342.   rep/address)
  343.  
  344. (define (%VM-UNMAP-AREA AREA)
  345.   (check-status (ms_$unmap (area-begin area) (area-size area) nil))
  346.   (no-value))
  347.  
  348. (define-foreign ms_$unmap
  349.   ("MS_$UNMAP" (in  rep/integer address)
  350.              (in  rep/integer length)
  351.              (out rep/integer status))
  352.   ignore)
  353.  
  354. ;(define-unimplemented (VM-REMAP-AREA AREA))
  355.  
  356.  
  357. ;;; Foreign Procedures - see foreign.doc.
  358.  
  359. ;;; The syntax to define a foreign procedure is:
  360. ;;;
  361. ;;; (define-foreign name (aegis_name (IN     rep0 name)
  362. ;;;                                  (IN/OUT rep1 name)
  363. ;;;                                  (OUT    rep2 name)
  364. ;;;                                  ...)
  365. ;;;                return-rep)
  366. ;;;
  367. ;;; We return multiple values starting with the returned value and
  368. ;;; then the out paramaters in order, ignoring the return value
  369. ;;; if indicated.
  370.  
  371. (define-constant kg_$name_string 32)
  372.                
  373. (define (make-foreign-procedure symbol)
  374.   (let* ((s (symbol->string symbol))
  375.          (pad-length (fx- kg_$name_string
  376.                           (fixnum-min (string-length s)
  377.                                       kg_$name_string)))
  378.          (xeno (make-foreign symbol))
  379.          (addr (kg_$lookup (string-append
  380.                             s
  381.                             (string-fill (make-string pad-length)
  382.                                          #\space)))))
  383.     (cond ((fxn= addr 0)
  384.            (set (mref-integer xeno 4) addr)
  385.            xeno)
  386.           (else
  387.            (error "KG-lookup on foreign procedure ~s failed" symbol)))))
  388.  
  389. ;++ rep/address should be made to work correctly (cons a xenoid).
  390.  
  391. (define-foreign kg_$lookup 
  392.     ("KG_$LOOKUP" (in rep/string))
  393.     rep/address)
  394.  
  395.  
  396. ;;; Load an Aegis binary file.
  397.  
  398.  
  399. ;;; From /us/ins/loader.ins.pas .
  400.  
  401. (define-foreign pm_$load
  402.   ("PM_$LOAD"  (in rep/string)         ;;; In Name: Univ Name_$Pname_T
  403.              (in rep/integer-16-u)   ;;; In Len:  Integer;
  404.              (in rep/integer-16-u)   ;;; In Opts: PM_$Loader_Opts;
  405.              (in rep/integer-16-u)   ;;; In  N_Sects:  Integer;
  406.              (ignore rep/extend)     ;;; Out Info:     Univ PM_$Load_Info;
  407.              (out rep/integer))      ;;; Out Status: Status_T
  408.   ignore)
  409.  
  410. (define-set-of pm_$opts
  411.                pm_$copy_proc
  412.                pm_$install
  413.                pm_$no_unresolveds
  414.                pm_$load_global
  415.                pm_$install_sections)
  416.  
  417. (define (load-foreign file)
  418.   (let ((out (standard-output) ))
  419.     (bind ((*load-level* (fx+ *load-level* 1)))
  420.       (comment-indent out (fx* *load-level* 2))
  421.       (format out "Loading foreign ~s~%" file)
  422.       (let* ((fname (->filename file))
  423.              (type  (filename-type fname))
  424.              (file  (->pathname (if (null? type)
  425.                                     (filename-with-type fname 'bin)
  426.                                     fname)))
  427.              (status (pm_$load file
  428.                                (string-length file)
  429.                                pm_$install
  430.                                0
  431.                                (make-bytev 8)    ; 4+4+0*(32+4+4) = 8
  432.                                0)))
  433.         (if (fxN= 0 status)
  434.             (error "Couldn't load ~S~%**~10t~a"
  435.                    file
  436.                    (local-os-error-message status)))))))
  437.